﻿Public Class rtfwrite

    ''' <summary>
    ''' 文件头
    ''' </summary>
    ''' <remarks></remarks>
    Private m_RtfHead As String
    ReadOnly Property RtfHead() As String
        Get
            Return "{\rtf1\ansi\ansicpg936\uc2\deff0\stshfdbch13\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe2052"
        End Get
    End Property
    ''' <summary>
    ''' 返回字体表
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function RtfFonttable() As String


        'f0、f1、f13、f17、f39
        Dim f As String = "{\fonttbl"
        Dim f0 As String = "{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman{\*\falt Times New Roman};}"
        Dim f1 As String = "{\f1\fswiss\fcharset0\fprq2{\*\panose 020b0604020202020204}Arial{\*\falt Arial};}"
        Dim f13 As String = "{\f13\fnil\fcharset134\fprq2{\*\panose 02010600030101010101}\'cb\'ce\'cc\'e5{\*\falt \'cb\'ce\'cc\'e5};}"
        Dim f17 As String = "{\f17\fnil\fcharset134\fprq2{\*\panose 02010600030101010101}\'ba\'da\'cc\'e5{\*\falt \'ba\'da\'cc\'e5};}"
        Dim f39 As String = "{\f39\fnil\fcharset134\fprq2{\*\panose 02010600030101010101}@\'cb\'ce\'cc\'e5;}"
        Dim f40 As String = "{\f40\fnil\fcharset134\fprq2{\*\panose 02010600030101010101}@\'ba\'da\'cc\'e5;}"
        Dim f578 As String = "{\f578\froman\fcharset238\fprq2 Times New Roman CE{\*\falt Times New Roman};}"
        Dim f579 As String = "{\f579\froman\fcharset204\fprq2 Times New Roman Cyr{\*\falt Times New Roman};}"
        Dim f581 As String = "{\f581\froman\fcharset161\fprq2 Times New Roman Greek{\*\falt Times New Roman};}"
        Dim f582 As String = "{\f582\froman\fcharset162\fprq2 Times New Roman Tur{\*\falt Times New Roman};}"
        Dim f583 As String = "{\f583\froman\fcharset177\fprq2 Times New Roman (Hebrew){\*\falt Times New Roman};}"
        Dim f584 As String = "{\f584\froman\fcharset178\fprq2 Times New Roman (Arabic){\*\falt Times New Roman};}"
        Dim f585 As String = "{\f585\froman\fcharset186\fprq2 Times New Roman Baltic{\*\falt Times New Roman};}"
        Dim f586 As String = "{\f586\froman\fcharset163\fprq2 Times New Roman (Vietnamese){\*\falt Times New Roman};}"
        Dim f588 As String = "{\f588\fswiss\fcharset238\fprq2 Arial CE{\*\falt Arial};}"
        Dim f589 As String = "{\f589\fswiss\fcharset204\fprq2 Arial Cyr{\*\falt Arial};}"
        Dim f591 As String = "{\f591\fswiss\fcharset161\fprq2 Arial Greek{\*\falt Arial};}"
        Dim f592 As String = "{\f592\fswiss\fcharset162\fprq2 Arial Tur{\*\falt Arial};}"
        Dim f593 As String = "{\f593\fswiss\fcharset177\fprq2 Arial (Hebrew){\*\falt Arial};}"
        Dim f594 As String = "{\f594\fswiss\fcharset178\fprq2 Arial (Arabic){\*\falt Arial};}"
        Dim f595 As String = "{\f595\fswiss\fcharset186\fprq2 Arial Baltic{\*\falt Arial};}"
        Dim f596 As String = "{\f596\fswiss\fcharset163\fprq2 Arial (Vietnamese){\*\falt Arial};}"
        Dim f710 As String = "{\f710\fnil\fcharset0\fprq2 SimSun Western{\*\falt \'cb\'ce\'cc\'e5};}"
        Dim f970 As String = "{\f970\fnil\fcharset0\fprq2 @\'cb\'ce\'cc\'e5 Western;}}" '连续两个大括号
        '————————————————————————————————————————————————————————————————————————
        RtfFonttable = vbCrLf + f + f0 + vbCrLf + f1 + vbCrLf + f13 + vbCrLf + f17 + vbCrLf + f39 + vbCrLf + f40 _
                       + vbCrLf + f578 + vbCrLf + f579 + vbCrLf + f581 + vbCrLf + f582 + vbCrLf + f583 + vbCrLf + f584 _
                       + vbCrLf + f585 + vbCrLf + f586 + vbCrLf + f588 + vbCrLf + f589 + vbCrLf + f591 + vbCrLf + f592 _
                       + vbCrLf + f593 + vbCrLf + f594 + vbCrLf + f595 + vbCrLf + f596 + vbCrLf + f710 + vbCrLf + f970

    End Function
    ''' <summary>
    ''' 返回颜色表，暂时不返回任何颜色表，默认为黑色
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function RtfColortable() As String
        RtfColortable = "{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}"

    End Function
    ''' <summary>
    ''' 返回表格样式，只采用单一网格样式
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function Rtfstylesheet() As String
        Dim s As String = " {\stylesheet"
        Dim s0 As String = "{\qj \li0\ri0\nowidctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs21\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 \snext0 \styrsid7883204 Normal;}"
        Dim s1 As String = "{\s1\qj \fi-432\li432\ri0\sl360\slmult1\widctlpar\jclisttab\tx432\aspalpha\aspnum\faauto\ls3\outlinelevel0\adjustright\rin0\lin432\itap0 \fs32\lang1033\langfe2052\kerning36\loch\f17\hich\af13\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext1 \sautoupd \styrsid6161727 heading 1;}"
        Dim s2 As String = "{\s2\qj \fi-576\li576\ri0\sl360\slmult1\keep\keepn\nowidctlpar\jclisttab\tx576\aspalpha\aspnum\faauto\ls3\ilvl1\outlinelevel1\adjustright\rin0\lin576\itap0 \fs30\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \sautoupd \slink17 \styrsid6161727 heading 2;}"
        Dim s3 As String = "{\s3\qj \fi-720\li720\ri0\sl360\slmult1\keep\keepn\nowidctlpar\jclisttab\tx720\aspalpha\aspnum\faauto\outlinelevel2\adjustright\rin0\lin720\itap0 \fs28\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \sautoupd \styrsid7883204 heading 3;}"
        Dim s4 As String = "{\s4\qj \fi-864\li864\ri0\sl360\slmult1\keep\keepn\nowidctlpar\jclisttab\tx864\aspalpha\aspnum\faauto\outlinelevel3\adjustright\rin0\lin864\itap0 \fs24\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \sautoupd \styrsid7883204 heading 4;}"
        Dim s5 As String = "{\s5\qj \fi-1008\li1008\ri0\sl360\slmult1\keep\keepn\nowidctlpar\jclisttab\tx1008\aspalpha\aspnum\faauto\ls3\ilvl4\outlinelevel4\adjustright\rin0\lin1008\itap0 \b\fs24\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \sautoupd \styrsid6161727 heading 5;}"
        Dim s6 As String = "{\s6\qj \fi-1152\li1152\ri0\sb240\sa64\sl320\slmult1\keep\keepn\nowidctlpar\jclisttab\tx1152\aspalpha\aspnum\faauto\outlinelevel5\adjustright\rin0\lin1152\itap0 \b\fs24\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \styrsid7883204 heading 6;}"
        Dim s7 As String = "{\s7\qj \fi-1296\li1296\ri0\sb240\sa64\sl320\slmult1\keep\keepn\nowidctlpar\jclisttab\tx1296\aspalpha\aspnum\faauto\outlinelevel6\adjustright\rin0\lin1296\itap0 \b\fs24\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \styrsid7883204 heading 7;}"
        Dim s8 As String = "{\s8\qj \fi-1440\li1440\ri0\sb240\sa64\sl320\slmult1\keep\keepn\nowidctlpar\jclisttab\tx1440\aspalpha\aspnum\faauto\outlinelevel7\adjustright\rin0\lin1440\itap0 \fs24\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \styrsid7883204 heading 8;}"
        Dim s9 As String = "{\s9\qj \fi-1584\li1584\ri0\sb240\sa64\sl320\slmult1\keep\keepn\nowidctlpar\jclisttab\tx1584\aspalpha\aspnum\faauto\outlinelevel8\adjustright\rin0\lin1584\itap0 \fs21\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext0 \styrsid7883204 heading 9;}"
        Dim s10 As String = "{\*\cs10 \additive \slink15 \slocked \ssemihidden Default Paragraph Font;}"
        Dim s11 As String = "{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv \ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\loch\f0\hich\af0\dbch\af13\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}"
        Dim s15 As String = "{\s15\qj \li0\ri0\nowidctlpar\aspalpha\aspnum\faauto\nosnaplinegrid\rin0\lin0\itap0 \fs24\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext15 \slink10 \ssemihidden \styrsid7883204 Char Char Char Char Char Char;}"
        Dim s17 As String = "{\*\cs17 \additive \fs32\lang1033\langfe2052\kerning2\loch\f1\hich\af1\dbch\af17\langnp1033\langfenp2052 \sbasedon10 \slink2 \slocked \styrsid7883204 \'b1\'ea\'cc\'e2 2 Char;}"
        Dim s18 As String = "{\s18\qj \li0\ri0\nowidctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \cbpat9 \fs21\lang1033\langfe2052\kerning2\loch\f0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 \sbasedon0 \snext18 \ssemihidden \styrsid7883204 Document Map;}}"

        'Return s + s0 + vbCrLf + s1 + vbCrLf + s2 + vbCrLf + s3 + vbCrLf + s4 + vbCrLf + s5 + vbCrLf _
        '+ s6 + vbCrLf + s7 + vbCrLf + s8 + vbCrLf + s9 + vbCrLf + s10 + vbCrLf + s11 + vbCrLf + s15 + vbCrLf + s17 + vbCrLf + s18

        Return s + s0 + s1 + s2 + s3 + vbCrLf + s4 + vbCrLf + s5 + vbCrLf _
          + s6 + vbCrLf + s7 + vbCrLf + s8 + vbCrLf + s9 + vbCrLf + s10 + vbCrLf + s11 + vbCrLf + s15 + vbCrLf + s17 + vbCrLf + s18

    End Function
    ''' <summary>
    '''生成器信息
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function Rtfgenener() As String
        Dim Hk As String = "NoiseSystem Rrfwriter"
        Dim f1 As String = "{\*\generator " + StrToRtf(Hk) + "}"

        Return f1
    End Function
    ''' <summary>
    ''' 文档信息
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function documentinfo() As String

        Dim f2 As String = "{\info{\title 1}"
        Dim f3 As String = "{\author " + StrToRtf("华安科技") + "}"  '作者信息
        Dim f4 As String = "{\title " + StrToRtf("噪声预测评价概述") + "}" '标题
        Dim f5 As String = "{\creatim\yr2012\mo12\dy22\min00}"
        Dim f6 As String = "{\revtim \yr2100 \mo01 \dy01 \hr01 \min01 }"
        Dim f7 As String = "{\version1}}}" '文档的版本号

        Return f2 + vbCrLf + f3 + vbCrLf + f4 + vbCrLf + f5 + vbCrLf + f6 + vbCrLf + f7

    End Function
    ''' <summary>
    ''' 页面控制信息
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function Rtfpagelayoutinfo() As String
        Dim f As String
        Dim f1 As String = "\paperw11906\paperh16838\margl1797\margr1797\margt1440\margb1440\gutter0"
        Dim f2 As String = "\deftab420\ftnbj\aenddoc\hyphcaps0\formshade\horzdoc\dgmargin\dghspace105\dgvspace156\dghorigin1797\dgvorigin1440\dghshow0\dgvshow2\jcompress\lnongrid"
        Dim f3 As String = "\viewkind1\viewscale100\splytwnine\ftnlytwnine\htmautsp\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct\asianbrkrule\rsidroot7883204\newtblstyruls\nogrowautofit "
        '关键字fchars后继避头尾字符列表,lchars前导避头尾字符列表
        Dim f4 As String = "{\*\fchars!),.:\'3b?]\'7d\'a1\'a7\'a1\'a4\'a1\'a6\'a1\'a5\'a8\'44\'a1\'ac\'a1\'af\'a1\'b1\'a1\'ad\'a1\'c3\'a1\'a2\'a1\'a3\'a1\'a8\'a1\'a9\'a1\'b5\'a1\'b7\'a1\'b9\'a1\'bb\'a1\'bf\'a1\'b3\'a1\'bd\'a3\'a1\'a3\'a2\'a3\'a7\'a3\'a9\'a3\'ac\'a3\'ae\'a3\'ba\'a3\'bb\'a3\'bf\'a3\'dd\'a3\'e0\'a3\'fc\'a3\'fd\'a1\'ab\'a1\'e9 }"
        Dim f5 As String = "{\*\lchars ([\'7b\'a1\'a4\'a1\'ae\'a1\'b0\'a1\'b4\'a1\'b6\'a1\'b8\'a1\'ba\'a1\'be\'a1\'b2\'a1\'bc\'a3\'a8\'a3\'ae\'a3\'db\'a3\'fb\'a1\'ea\'a3\'a4}"
        f = f1 + vbCrLf + f2 + vbCrLf + f3 + vbCrLf + f4 + vbCrLf + f5
        Return f
    End Function
    ''' <summary>
    ''' 分节控制信息
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function Rtfsegment() As String
        Dim segment As String
        Dim se0 As String = "\fet0\sectd \psz9\linex0\headery851\footery992\colsx425\endnhere\sectlinegrid312\sectspecifyl\sectrsid1070348\sftnbj "
        Dim pnseclvl1 As String = "{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta \dbch .}}"
        Dim pnseclvl2 As String = "{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang {\pntxta \dbch .}}"
        Dim pnseclvl3 As String = "{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta \dbch .}}"
        Dim pnseclvl4 As String = "{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta \dbch )}}"
        Dim pnseclvl5 As String = "{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb \dbch (}{\pntxta \dbch )}}"
        Dim pnseclvl6 As String = "{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb \dbch (}{\pntxta \dbch )}}"
        Dim pnseclvl7 As String = "{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb \dbch (}{\pntxta \dbch )}}"
        Dim pnseclvl8 As String = "{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb \dbch (}{\pntxta \dbch )}}"
        Dim pnseclvl9 As String = "{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb \dbch (}{\pntxta \dbch )}}"

        segment = se0 + vbCrLf & pnseclvl1 & vbCrLf & pnseclvl2 & vbCrLf + pnseclvl3 + vbCrLf + pnseclvl4 + vbCrLf + pnseclvl5 + vbCrLf + pnseclvl6 + vbCrLf + pnseclvl7 + vbCrLf + pnseclvl8 + vbCrLf + pnseclvl9
        Return segment
    End Function
    ''' <summary>
    ''' 将字符串转换成RTF编码
    ''' </summary>
    ''' <param name="strasc">任意字符串</param>
    ''' <returns>将字符串转换成纯ASCII的编码</returns>
    ''' <remarks></remarks>
    Public Function StrToRtf(ByVal strasc As String) As String

        Dim Zval As Integer = Val("z")
        Dim ret As New System.Text.StringBuilder


        For i As Integer = 0 To strasc.Length - 1
            Dim kk As String = strasc(i)

            If kk = "\\" Then
                ret.Append("\\\\")
            ElseIf kk = "\n" Then
                ret.Append("\\par ")
                '如果字符kk不是字符（是汉字） 则转化为ascii 编码
            ElseIf Asc(kk) < 0 Or Asc(kk) > 127 Then
                Dim targetEncoding As System.Text.Encoding
                Dim encodedChars As Byte()

                'Gets the encoding for the specified code page.
                targetEncoding = System.Text.Encoding.Default

                ' Gets the byte representation of the specified string

                encodedChars = targetEncoding.GetBytes(strasc(i))

                For j As Integer = 0 To encodedChars.Length - 1
                    Dim st As String
                    st = encodedChars(j).ToString
                    Integer.Parse(st).ToString("x")
                    ret.Append("\'").Append(Integer.Parse(st).ToString("X"))
                Next
                '如果是字符 则直接加入
            Else
                ret.Append(kk)
            End If
        Next

        Return ret.ToString

    End Function
    ''' <summary>
    ''' 一个RTF文档所有格式控制信息，暂时，不定期要添加
    ''' </summary>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function FileAllHead() As String

        Dim strFileAllHead As String = ""

        strFileAllHead = strFileAllHead + RtfHead
        strFileAllHead = strFileAllHead + RtfFonttable()
        strFileAllHead = strFileAllHead + RtfColortable()
        strFileAllHead = strFileAllHead + Rtfstylesheet()
        strFileAllHead = strFileAllHead + Rtfgenener()
        '  FileAllHead=documentinfo '格式有误

        strFileAllHead = strFileAllHead + Rtfpagelayoutinfo()
        strFileAllHead = strFileAllHead + Rtfsegment()

        Return strFileAllHead
    End Function
End Class
